-- | Jabber.hs
-- A module for interaction with XMPP.

module Jabber where

import Buffers
import Config
import Misc
import Network.XMPP
import Network.XMPP.MUC

import Network
import System.IO.Unsafe
import Control.Concurrent
import Graphics.Vty
import qualified Data.HashTable as H

-- | MVar for communication between mainLoop, eventLoop and jabber handlers.
updateEvent :: MVar (UpdateEvent a)
updateEvent = unsafePerformIO newEmptyMVar
data UpdateEvent a = VtyEvent Event | XMPPEvent Bool (StatusResult a)

-- | Fork main jabber loop and add handlers.
connectAndAuth :: Config
               -> Accounts
               -> (String, Account)
               -> IO (StatusResult a)
connectAndAuth config accounts (name, account) =
    case connection account of
      Nothing -> do
        configList <- H.toList config

        c <- openStream (server account)
        getStreamStart c
        forkIO $ runXMPP c $ do
          err <- startAuth (username account)
                           (server account)
                           (password account)
                           (resource account)
                           (priority account)
          if err == 0
            then do
              tId <- liftIO $ myThreadId
              let acc = account{connection=Just (c, tId)}
              liftIO $ H.update accounts name acc
              handleVersion (getConfigValue "client" configList)
                            (getConfigValue "version" configList)
                            (getConfigValue "OS" configList)
              addHandler groupchatHandler
                         (groupchatCB accounts name acc)
                         True
              addHandler chatHandler
                         (chatCB accounts name acc)
                         True
              addHandler rosterHandler
                         (rosterCB accounts name acc)
                         True
              addHandler presenceHandler
                         (presenceCB accounts name acc)
                         True
              addHandler restHandler
                         (liftIO . putNewStanza accounts name UnknownMsg)
                         True
              queryRoster
              liftIO $ putMVar updateEvent $ XMPPEvent True $
                StatusResult $ Right (undefined, "connected to "++name)
            else liftIO $ putMVar updateEvent $ XMPPEvent True $
                   StatusResult $ Left $ "can't connect to "++name++
                                         ": "++(show err)++" error"
        return $
          StatusResult $ Right $ (undefined, "connecting to "++name++"...")
      _ -> return $ StatusResult $ Left $ name++" already connected"
  where
    presenceHandler = isPresence
    groupchatHandler = isGroupchatMessage `conj` hasBody
    chatHandler = isChat
    rosterHandler = iqXmlns "jabber:iq:roster"
    restHandler = (not . groupchatHandler) `conj` (not . rosterHandler) `conj` (not . presenceHandler) `conj` (not . chatHandler)
    queryRoster = sendIq "" "get" [XML "query" [("xmlns", "jabber:iq:roster")] []]

-- | Leave all rooms and call disconnect.
accDisconnect :: (String, Account) -> IO (StatusResult (String, Account))
accDisconnect (name, account) =
    case connection account of
      Just conn -> do
        -- leave all rooms
        H.toList (users account) >>=
          mapM_ (\(room,_) -> accLeaveGroupchat room (name, account)) .
            filter (\(_,value) -> case value of
                                    UserGroupchat _ -> True
                                    _ -> False)
        disconnect conn
        return $ StatusResult $ Right (( name
                                       , account{connection = Nothing}
                                       ), name++" disconnected")
      _ -> return $ StatusResult $ Left $ name++" not connected"

-- | Kill forked thread and close connection.
disconnect :: (TCPConnection, ThreadId) -> IO ()
disconnect (c, tId) = do
    killThread tId
    closeConnection c
    return ()

accJoinGroupchat :: String -> (String, Account) -> IO (StatusResult a)
accJoinGroupchat jid (name, account) =
    case connection account of
      Just (c, _) -> do
        let room = getBareJid jid
            nick' = getResource jid
            nick = if null nick'
                   then defaultNick account
                   else nick'
        groupchat <- H.lookup (users account) room
        case groupchat of
          Nothing -> do
            subchats' <- H.new (==) H.hashString
            H.insert (users account) room
              (UserGroupchat Groupchat{ groupchatContents = []
                                      , groupchatNick = nick
                                      , subchats = subchats'
                                      , groupchatAlert = AlertNone
                                      })
            runXMPP c $ joinGroupchat nick room "" >> return ()
            return $ StatusResult $
              Right (undefined, name++" joined a "++room++" as "++nick)
          _ -> return $ StatusResult $ Left $ name++" already in "++room
      _ -> return $ StatusResult $ Left $ name++" not connected"

accLeaveGroupchat :: String -> (String, Account) -> IO (StatusResult a)
accLeaveGroupchat room (name, account) =
    case connection account of
      Just (c, _) -> do
        groupchat <- H.lookup (users account) room
        case groupchat of
          Just _ -> do
            runXMPP c $ leaveGroupchat room
            H.delete (users account) room
            return $ StatusResult $ Right (undefined, name++" leaved a "++room)
          _ -> return $ StatusResult $ Left $ name++" not in "++room
      _ -> return $ StatusResult $ Left $ name++" not connected"

accSendGroupchat :: String -> String -> (String, Account) -> IO (StatusResult a)
accSendGroupchat room msg (name, account) =
    case connection account of
      Just (c, _) -> do
        groupchat <- H.lookup (users account) room
        case groupchat of
          Just _ -> do
            runXMPP c $ sendGroupchatMessage room msg
            return $ StatusResult $ Right (undefined, "")
          _ -> return $ StatusResult $ Left $ name++" not in "++room
      _ -> return $ StatusResult $ Left $ name++" not connected"

accSendChat :: String -> String -> (String, Account) -> IO (StatusResult a)
accSendChat jid text (name, account) = do
    time <- liftIO nowTime
    case connection account of
      Just (c, _) -> do
        item <- H.lookup (users account) jid
        case item of
          Just (UserRosterItem item') -> do
            runXMPP c $ sendMessage jid text
            let contents = (itemContents item') ++ [MyMsg $ "["++time++"] <"++(defaultNick account)++"> "++text]
            liftIO $ H.update (users account) jid
              (UserRosterItem item' {itemContents = contents})
            liftIO $ putMVar updateEvent $ XMPPEvent False $
              StatusResult $ Right (undefined, "")
            return $ StatusResult $ Right (undefined, "")
          _ -> return $ StatusResult $ Left $ "could not send message to " ++jid ++ "/" ++ name ++ "/"
      _ -> return $ StatusResult $ Left $ name++" not connected"

accSetStatus :: RosterItemStatus -> Maybe Integer -> (String, Account) -> IO (StatusResult a)
accSetStatus status prio (name, account) =
    case connection account of
      Just (c, _) -> do
            runXMPP c $ sendPresence (Just $ statusToString status) prio
            return $ StatusResult $ Right (undefined, "")
      _ -> return $ StatusResult $ Left $ name++" not connected"


-----------------------------------------------

-- | Callback for groupchat. If have message then update buffers and set MVar.
groupchatCB :: Accounts -> String -> Account -> StanzaHandler
groupchatCB accounts name account stanza = do
    time <- liftIO $ if isHistoryMsg
                     then utcToZoned $ maybe "" id (getAttr "stamp" x)
                     else nowTime

    let sender = maybe "" id (getAttr "from" stanza)
        body = maybe "" id (getMessageBody stanza)
        room = getBareJid sender
        nick = getResource sender
        msg = "["++time++"] <"++nick++"> "++body

    groupchat <- liftIO $ H.lookup (users account) room
    case groupchat of
      Just (UserGroupchat groupchat') -> do
        let pns f m = do liftIO $ putNewStanza accounts name f stanza
                         return $ f m
            urgent = if isHistoryMsg || nick == (groupchatNick groupchat')
                      then groupchatAlert groupchat'
                      else AlertNotify

        content <- if isHistoryMsg
                    then pns HistoryMsg msg
                    else if nick == groupchatNick groupchat'
                            then pns MyMsg msg
                            else pns Msg msg
        let contents = groupchatContents groupchat' ++ [content]
        liftIO $ H.update (users account) room
          (UserGroupchat groupchat'{groupchatContents = contents, groupchatAlert = urgent})
        liftIO $ putMVar updateEvent $ XMPPEvent False $
          StatusResult $ Right (undefined, "")
      _ -> liftIO $ putNewStanza accounts name UnknownMsg stanza
  where
    x = maybe (XML [] [] []) id (xmlPath ["x"] stanza)
    isHistoryMsg = attributeMatches "xmlns" (=="jabber:x:delay") x


-- | Callback for chat. If have message then update buffers and set MVar.
chatCB :: Accounts -> String -> Account -> StanzaHandler
chatCB accounts name account stanza = do
    time <- liftIO $ if isHistoryMsg
                     then utcToZoned $ maybe "" id (getAttr "stamp" x)
                     else nowTime

    let sender = maybe "" id (getAttr "from" stanza)
        body = maybe "" id (getMessageBody stanza)
        jid = getBareJid sender

    item <- liftIO $ H.lookup (users account) jid
    case item of
      Just (UserRosterItem item') -> do
        let pns f m = do liftIO $ putNewStanza accounts name f stanza
                         return $ f m
        let contents = itemContents item' ++ [Msg $ "["++time++"] <"++(itemName item')++"> "++body]
        liftIO $ H.update (users account) jid
          (UserRosterItem item'{itemContents = contents, itemAlert = AlertUrgent})
        liftIO $ putMVar updateEvent $ XMPPEvent False $
          StatusResult $ Right (undefined, "")
      _ -> liftIO $ putNewStanza accounts name UnknownMsg stanza
  where
    x = maybe (XML [] [] []) id (xmlPath ["x"] stanza)
    isHistoryMsg = attributeMatches "xmlns" (=="jabber:x:delay") x

-- | Processing received roster items.
processRosterItems :: Accounts -> String -> Account -> [XMLElem] -> IO ()
processRosterItems accounts name account [] =
	return ()
processRosterItems accounts name account (e:es) = do
	time <- liftIO nowTime
	let
		jid = maybe "" id (getAttr "jid" e)
		name = maybe jid id (getAttr "name" e)
		cs = allChilds e
		groups = map (maybe "[Unknown]" id . getCdata) $ filter (hasNodeName "group") cs
		msg = "["++time++"] "++name++" ("++jid++") online"
	
	putNewStanza accounts name UnknownMsg e
	mayberoster <- liftIO $ H.lookup (users account) jid
	case mayberoster of
	    Just item -> return ()
	    Nothing -> do
		H.insert (users account) jid (UserRosterItem RosterItem {itemJid = jid
		    ,itemName = name
		    ,itemGroups = groups
		    ,itemContents = []
		    ,itemStatus = StatusOffline Nothing
		    ,itemAlert = AlertNone})
	processRosterItems accounts name account es

-- | Updating received presence for the item
processPresence' account jid status = do
	maybeuser <- liftIO $ H.lookup (users account) jid
	case maybeuser of
		Just (UserRosterItem item) -> H.update (users account) jid (UserRosterItem item{itemStatus = status})
		_ -> return False 

-- | Dispatching presence types	
processPresence accounts name account jid ptype pshow status priority = do
	let
		bare = getBareJid jid
		status' | status == "" = Nothing
			| otherwise = Just status
	case ptype of
		"" -> case pshow of
			"away" -> processPresence' account bare (StatusAway status')
			"chat" -> processPresence' account bare (StatusChat status')
			"dnd"  -> processPresence' account bare (StatusDND status')
			"xa"   -> processPresence' account bare (StatusXA status')
			_      -> processPresence' account bare (StatusOnline status')
		"unavailable" -> processPresence' account bare (StatusOffline status')
		_ -> return True
	return True

-- | Roster handler
rosterCB :: Accounts -> String -> Account -> StanzaHandler
rosterCB accounts name account stanza = do
	let 
		query = maybe (XML [] [] []) id (xmlPath ["query"] stanza)
		(XML _ _ els) = query
		msg = xmlToString True stanza ++ "\n"
		contents = accountContents account ++ [UnknownMsg msg]
	liftIO $ processRosterItems accounts name account els
	liftIO $ H.update accounts name account{accountContents=contents}
	liftIO $ putMVar updateEvent $ XMPPEvent True $
		StatusResult $ Right (undefined, "")
	sendPresence Nothing (Just $ priority account)
	return ()

-- | Presence handler
presenceCB :: Accounts -> String -> Account -> StanzaHandler
presenceCB accounts name account stanza = do
	let
		jid = maybe "" id (getAttr "from" stanza)
		ptype = maybe "" id (getAttr "type" stanza)
		pshow = maybe "" id (getCdata $ maybe (XML [] [] []) id (xmlPath ["show"] stanza))
		status = maybe "" id (getCdata $ maybe (XML [] [] []) id (xmlPath ["status"] stanza))
		priority = maybe "0" id (getAttr "priority" stanza)
		msg = "Presence received from " ++ jid ++ " type=" ++ ptype ++ " show=" ++ pshow ++ "\n"
		contents = accountContents account ++ [UnknownMsg msg]
	liftIO $ processPresence accounts name account jid ptype pshow status priority
	liftIO $ H.update accounts name account{accountContents=contents}
	liftIO $ putMVar updateEvent $ XMPPEvent True $
		StatusResult $ Right (undefined, "presence stanza from "++jid)
	return ()


-- | Put new stanza to the account contents.
putNewStanza :: Accounts -> String -> (String -> Content) -> XMLElem -> IO ()
putNewStanza accounts name toContent stanza = do
  maybeAccount <- H.lookup accounts name
  case maybeAccount of
    Just account -> do
      let msg = xmlToString True stanza ++ "\n"
          contents = accountContents account ++ [toContent msg]
      liftIO $ H.update accounts name account{accountContents=contents}
      return ()
    _ -> return ()
